home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 12C.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  38KB  |  1,285 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* chapter 12, part c */
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "attr.h"
  13. #include "dbxp.h"
  14. #include "dclmapp.h"
  15. #include "miscp.h"
  16. #include "smiscp.h"
  17. #include "setp.h"
  18. #include "nodesp.h"
  19. #include "errmsgp.h"
  20. #include "chapp.h"
  21.  
  22. /* ctype.h needed by desig_to_op */
  23. #include <ctype.h>
  24.  
  25. static Tuple instantiation_code;        /* code from instantiation */
  26. static int instantiation_code_n = 0;    /* current length */
  27.  
  28. static Node instantiate_object(Node, Symbol, Symbolmap);
  29. static int can_rename(Node);
  30. static Tuple flatten_tree(Node);
  31. static int is_discr_ref(Node, Tuple);
  32. static Symbol instantiate_type(Node, Symbol, Symbolmap);
  33. static Symbol valid_type_instance(Symbol, Symbol, Symbolmap);
  34. static Symbol valid_scalar_instance(Symbol, Symbol, Symbolmap);
  35. static void check_actual_constraint(Symbol, Symbol);
  36. static Symbol valid_priv_instance(Symbol, Symbol, Symbolmap);
  37. static Symbol valid_access_instance(Symbol, Symbol, Symbolmap);
  38. static Symbol valid_array_instance(Symbol, Symbol, Symbolmap);
  39. static int is_valid_disc_instance(Symbol, Symbol, Symbolmap);
  40. static Tuple get_array_info(Symbol);
  41. static void generic_subprog_instance(Node, Symbol, Symbolmap, int);
  42. static Tuple find_renamed_types(int, Tuple, Symbol, Node);
  43. static Node make_rename_node(Symbol, Node);
  44. static void instantiation_code_with(Node);
  45.  
  46. /* number of slots to expand instantiation_code when full, initial alloc*/
  47. #define INSTANTIATION_CODE_INC    50
  48.  
  49. Tuple instantiate_generics(Tuple gen_list, Node instance_node)
  50.   /*;instantiate_generics*/
  51. {
  52.     /* Produce the list of renamings which transforms generic parameters
  53.      * into actual ones.
  54.      * Generic types play a special role in this renaming. We collect the
  55.      * Instantiations of generic types into the map     -type_map-and use it
  56.      * in a substitution procedure to obtain the signature of generic
  57.      * subprogram arguments.
  58.      * Generic subprograms are also renamed by the actual subprograms, and
  59.      * the mapping from one to the other is also added to the same renaming
  60.      * map.
  61.      */
  62.  
  63.     Tuple    error_instance, empty_tuple, inst_code;
  64.     Symbolmap    type_map, empty_typemap;
  65.     Tuple    gtup;
  66.     Tuple    instance, new_instance;
  67.     int        i, j, k, gn, ni, seen, same_formal_subprog;
  68.     Node    assoc;
  69.     int        first_named, exists, is_default;
  70.     Symbol    g_name, name, over;
  71.     Node    actual;
  72.     Symbol    actual_type;
  73.     Node    init_node;
  74.     Node    id_node;
  75.     Tuple    tup;
  76.     int        nat;
  77.     Fortup    ft1;
  78.     Forset  fs1;
  79.  
  80.     if( cdebug2 > 3) TO_ERRFILE("AT PROC :  instantiate_generics ");
  81.  
  82.     /*    const error_instance = [ [], {} ];        $$ES7 */
  83.     instantiation_code = tup_new(0);
  84.     instantiation_code_n = 0;
  85.     type_map = symbolmap_new();
  86.     empty_tuple = tup_new(0);
  87.     empty_typemap = symbolmap_new();
  88.     error_instance = tup_new2((char *) empty_tuple, (char *) empty_typemap);
  89.     instance = N_LIST(instance_node);
  90.  
  91.     if (tup_size( instance) > tup_size( gen_list)){
  92.         errmsg("Too many actuals in generic instantiation", "12.3", instance_node);
  93.     }
  94.  
  95.     /* Values may be supplied either positionally or by name.  */
  96.     exists = FALSE;
  97.     FORTUPI(assoc=(Node), instance, i, ft1);
  98.         if (N_AST1(assoc) != OPT_NODE){
  99.             exists = TRUE;
  100.             break;
  101.         }
  102.     ENDFORTUP(ft1);
  103.     if (exists) {
  104.         first_named = i;
  105.         exists = FALSE;
  106.         for (k=i; k <= tup_size(instance); k++) {
  107.             if (N_AST1((Node)instance[k]) == OPT_NODE){
  108.                 exists = TRUE;
  109.                 break;
  110.             }
  111.         }
  112.         if (exists) {
  113.             errmsg("Positional association after named one", "12.3",
  114.               (Node)instance[k]);
  115.             return error_instance;
  116.         }
  117.     }
  118.     else
  119.         first_named = tup_size(instance) + 1;
  120.     seen = first_named - 1;
  121.     new_instance = tup_new(0);
  122.     for (i = 1; i <= seen; i++) {
  123.         actual = N_AST2((Node)instance[i]);
  124.         new_instance = tup_with(new_instance, (char *) actual);
  125.     }
  126.  
  127.     /* Collect named instances in the proper order.*/
  128.     gn = tup_size(gen_list);
  129.     for (i=first_named; i <= gn; i++) {
  130.         gtup = (Tuple) gen_list[i];
  131.         g_name = (Symbol) gtup[1];
  132.         init_node = (Node) gtup[2];
  133.         exists = FALSE;
  134.         ni = tup_size(instance);
  135.         for (j=first_named; j <= ni; j++) {
  136.             id_node = N_AST1((Node) instance[j]);
  137.             if (id_node == OPT_NODE) continue;
  138.             if (streq(N_VAL(id_node), ORIG_NAME(g_name))) {
  139.                 exists = TRUE;
  140.                 break;
  141.             }
  142.         }
  143.         if (exists) {
  144.             actual = N_AST2((Node) instance[j]);
  145.             new_instance = tup_with(new_instance, (char *) actual);
  146.             seen += 1;
  147.  
  148.             if (NATURE(g_name) == na_procedure || 
  149.                 NATURE(g_name) == na_function) {
  150.                name = dcl_get(DECLARED(SCOPE_OF(g_name)), N_VAL(id_node));
  151.                         /*
  152.                          * We must distinguish between generic formal
  153.                          * subprogram and those defined in the generic spec.
  154.                          * We perform the check only on those defined in the
  155.                          * generic spec (i.e. those that have their ALIAS 
  156.                          * field defined.
  157.                          */
  158.                same_formal_subprog = 0;
  159.                FORSET(over = (Symbol), OVERLOADS(name), fs1);
  160.                   if (ALIAS(over)!=(Symbol)0) same_formal_subprog++;
  161.                ENDFORSET(fs1);
  162.                if (same_formal_subprog > 1) 
  163.                    errmsg("named associations not allowed for overloaded names",
  164.                       "12.3(3)", id_node);
  165.             }
  166.             /* Otherwise a default must exist for this generic parameter.*/
  167.             /* Mark the place for use below.*/
  168.         }
  169.         else if (init_node != OPT_NODE ) 
  170.             new_instance = tup_with(new_instance, (char *) OPT_NODE);
  171.         else {
  172.             errmsg_id("Missing instantiation for generic parameter %" ,
  173.               g_name, "12.3", current_node);
  174.             return error_instance;
  175.         }
  176.     }
  177. #ifdef TBSN
  178.     if (cdebug2 > 0){
  179.         TO_ERRFILE('new instance ' + str new_instance);
  180.     }
  181. #endif
  182.     /* Now process all actuals in succession. */
  183.     gn = tup_size(gen_list);
  184.     for (i = 1; i <= gn; i++) {
  185.         gtup= (Tuple) gen_list[i];
  186.         g_name = (Symbol) gtup[1];
  187.         init_node = (Node) gtup[2];
  188.         actual = (Node) new_instance[i];
  189.  
  190.         if (actual != OPT_NODE ) {
  191.             adasem(actual);
  192.             if (NATURE(g_name) == na_in) {
  193.                 /* type check expression for in parameter. */
  194.                 actual_type = replace(TYPE_OF(g_name), type_map);
  195.                 check_type(actual_type, actual);
  196.             }
  197.             else if (NATURE(g_name)== na_procedure
  198.               || NATURE(g_name)== na_function) {
  199.                 /* Actual may be given by an operator symbol, which appear  */
  200.                 /*  as string literal. */
  201.                 is_default = FALSE;
  202.                 if (N_KIND(actual) == as_string_literal)
  203.                     desig_to_op(actual);
  204.                 find_old(actual);
  205.             }
  206.         }
  207.         else {
  208.             /* Use default value given.*/
  209.             actual = init_node;
  210.             if (NATURE(g_name) == na_in )
  211.                 /* May depend on generic types: replace by their instances.*/
  212.                 actual = instantiate_tree(init_node, type_map);
  213.             else    {        /* generic subprogram parameter */
  214.                 /* If the box was used to specify a default subprogram, we
  215.                  * retrieve the visible instances of the generic identifier.
  216.                  */
  217.                 is_default = TRUE;
  218.                 if (N_KIND(actual) == as_simple_name
  219.                   && streq(N_VAL(actual), "box")) {
  220.                     actual = node_new(as_simple_name);
  221.                     N_VAL(actual) = original_name(g_name);
  222.                     copy_span(instance_node, actual);
  223.                     find_old(actual);
  224.                     is_default = FALSE;
  225.                 }
  226.                 else if (N_KIND(actual) == as_attribute)
  227.                     /* Will depend on generic types. Must instantiate. */
  228.                     actual = instantiate_tree(init_node, type_map);
  229.             }
  230.         }
  231.         nat = NATURE(g_name);
  232.         if (nat == na_in || nat == na_inout)
  233.             /* TBSL: see if instantiation_code might be large in which case
  234.              * may want to avoid too many tup_with calls
  235.              */
  236.             instantiation_code_with(
  237.               instantiate_object(actual, g_name, type_map));
  238.         else if (nat == na_procedure || nat == na_function)
  239.             generic_subprog_instance(actual, g_name, type_map, is_default);
  240.         else {            /* generic type. */
  241.             actual_type = instantiate_type(actual, g_name, type_map);
  242.             if (actual_type == (Symbol)0)
  243.                 return error_instance;
  244.             else {
  245.                 symbolmap_put(type_map, g_name, actual_type);
  246.                 if (is_scalar_type(g_name))
  247.                     /* indicate the instantiation of its base type as well. */
  248.                     symbolmap_put(type_map, TYPE_OF(g_name),
  249.                       base_type(actual_type));
  250.             }
  251.         }
  252.     }
  253.     if (seen != tup_size(instance)) {
  254.         /* Not all name